home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / library / tsl.f < prev    next >
Encoding:
Text File  |  1992-06-18  |  11.4 KB  |  380 lines
  1. C----------------------------------------------------------------------------
  2.  
  3. C  Module name: traversal state list module.
  4.  
  5. C  Author: Gareth Williams.
  6.  
  7. C  Function: This module contains functions for inquiring information
  8. C            from the PHIGS Traversal State List.
  9.  
  10. C  Dependencies: 
  11.  
  12. C  Internal function list: traversestruct, box
  13.  
  14. C  External function list: ptk_boundingbox
  15.  
  16. C  Hashtables used: none.
  17.  
  18. C  Modification history: (Version), (Date), (name), (Description).
  19.  
  20. C  1.0, 4th September 1991, G. Williams, First version.
  21.  
  22. C----------------------------------------------------------------------------
  23.  
  24.        SUBROUTINE ptkf_stacktsl()
  25. C /*
  26. C ** \blurb{This function puts the current TSL value on the TSL stack.}
  27. C */
  28.        external ptk_stacktsl !$PRAGMA C(ptk_stacktsl)
  29.  
  30.        call ptk_stacktsl()
  31.  
  32.        RETURN
  33.        END
  34.  
  35.        SUBROUTINE ptkf_unstacktsl()
  36. C /*
  37. C ** \blurb{This function gets the topmost TSL value from the TSL stack.}
  38. C */  
  39.        external ptk_unstacktsl !$PRAGMA C(ptk_unstacktsl)
  40.  
  41.        call ptk_unstacktsl()
  42.  
  43.        RETURN
  44.        END
  45.  
  46.        LOGICAL FUNCTION ptkf_boundingbox(structid, wcbounds, descend)
  47. C /*
  48. C ** \parambegin
  49. C ** \param{INTEGER}{structid}{structure network identifier}{IN}
  50. C ** \param{REAL}{wcbounds(6)}{bounding box in world coordinates}{OUT}
  51. C ** \param{LOGICAL}{descend}{flag to indicate traversal}{IN}
  52. C ** \paramend
  53. C ** \blurb{This function evaluates the bounding box for a structure or
  54. C ** structure network. If {\tt descend} 
  55. C ** is set to TRUE then the bounding box for the complete structure
  56. C ** network is returned, otherwise just for a single structure.
  57. C ** The function returns TRUE if the resulting bounding box is valid, 
  58. C ** otherwise FALSE. A structure with no output primitives returns an
  59. C ** invalid bounding box.}
  60. C */
  61.        INTEGER structid
  62.        REAL wcbounds(6)
  63.        LOGICAL descend
  64.        LOGICAL*1 ptk_boundingbox, ans, desc
  65.        external ptk_boundingbox !$PRAGMA C(ptk_boundingbox)
  66.  
  67.        desc = descend
  68.        ans = ptk_boundingbox(%val(structid), wcbounds, 
  69. & %val(desc))
  70.        if (ans .eq. 1) then
  71.           ptkf_boundingbox = .TRUE.
  72.        else
  73.           ptkf_boundingbox = .FALSE.
  74.        endif
  75.  
  76.        RETURN
  77.        END
  78.  
  79.        SUBROUTINE ptkf_inittsl()
  80. C /*
  81. C ** \blurb{This function initialises the current TSL values to the
  82. C ** default values from the PHIGS description table.
  83. C ** The default ASF value for each attribute is assumed to be INDIVIDUAL.}
  84. C */
  85.        external ptk_inittsl !$PRAGMA C(ptk_inittsl)
  86.  
  87.        call ptk_inittsl()
  88.  
  89.        RETURN
  90.        END
  91.  
  92.       SUBROUTINE ptkf_tsltraverserange(startstid, startelemid, 
  93. & stopstid, stopelemid, descend)
  94. C /*
  95. C ** \parambegin
  96. C ** \param{INTEGER}{startstid}{start structure identifier}{IN}
  97. C ** \param{INTEGER}{startelemid}{start element number}{IN}
  98. C ** \param{INTEGER}{stopstid}{stop structure identifier}{IN}
  99. C ** \param{INTEGER}{stopelemid}{stop element number}{IN}
  100. C ** \param{LOGICAL}{descend}{flag to indicate traversal}{IN}
  101. C ** \paramend
  102. C ** \blurb{This function makes TSL traverse between two points in a structure
  103. C ** network. If {\tt descend} is set to TRUE then any
  104. C ** EXECUTE STRUCTURE elements which occur between the two points
  105. C ** are followed, otherwise they are ignored.}
  106. C */
  107.       INTEGER startstid, startelemid, stopstid, stopelemid
  108.       LOGICAL descend
  109.       LOGICAL*1 desc
  110.       external ptk_tsltraverserange !$PRAGMA C(ptk_tsltraverserange)
  111.  
  112.       desc = descend
  113.       call ptk_tsltraverserange(%val(startstid), %val(startelemid), 
  114. & %val(stopstid), %val(stopelemid), %val(desc))
  115.  
  116.       RETURN
  117.       END
  118.  
  119.       SUBROUTINE ptkf_inqboundingbox(bbox)
  120. C /*
  121. C ** \parambegin
  122. C ** \param{REAL}{bbox(6)}{bounding box}{OUT}
  123. C ** \paramend
  124. C ** \blurb{This function may be used to obtain the current TSL bounding box
  125. C ** value. This is the bounding box of the TSL structure network at the
  126. C ** current point of traversal.}
  127. C */
  128.       REAL bbox(6)
  129.       external ptk_inqboundingbox !$PRAGMA C(ptk_inqboundingbox)
  130.  
  131.       call ptk_inqboundingbox(bbox)
  132.  
  133.       RETURN
  134.       END
  135.  
  136.        SUBROUTINE ptkf_inqtsledge(edgeind, edgeflag, edgetype, 
  137. & edgewidth, edgecolour)
  138. C /*
  139. C ** \parambegin
  140. C ** \param{INTEGER}{edgeind}{edge index}{OUT}
  141. C ** \param{INTEGER}{edgeflag}{edge flag}{OUT}
  142. C ** \param{INTEGER}{edgetype}{edge type}{OUT}
  143. C ** \param{REAL}{edgewidth}{edge width}{OUT}
  144. C ** \param{INTEGER}{edgecolour}{edge colour}{OUT}
  145. C ** \paramend
  146. C ** \blurb{This function may be used to obtain the current TSL 
  147. C ** edge attributes.}
  148. C */
  149.        INTEGER edgeind, edgeflag, edgetype
  150.        REAL edgewidth
  151.        INTEGER edgecolour
  152.        external ptk_inqtsledge !$PRAGMA C(ptk_inqtsledge)
  153.  
  154.        call ptk_inqtsledge(edgeind, edgeflag, edgetype, edgewidth, 
  155. & edgecolour)
  156.  
  157.        RETURN
  158.        END
  159.  
  160.        SUBROUTINE ptkf_inqtslline(lineind, linetype, linewidth, 
  161. & linecolour)
  162. C /*
  163. C ** \parambegin
  164. C ** \param{INTEGER}{lineind}{line index}{OUT}
  165. C ** \param{INTEGER}{linetype}{line type}{OUT}
  166. C ** \param{REAL}{linewidth}{line width}{OUT}
  167. C ** \param{INTEGER}{linecolour}{line colour}{OUT}
  168. C ** \paramend
  169. C ** \blurb{This function may be used to obtain the current TSL line 
  170. C ** attributes.}
  171. C */
  172.        INTEGER lineind, linetype
  173.        REAL linewidth
  174.        INTEGER linecolour
  175.        external ptk_inqtslline !$PRAGMA C(ptk_inqtslline)
  176.  
  177.        call ptk_inqtslline(lineind, linetype, linewidth, linecolour)
  178.  
  179.        RETURN
  180.        END
  181.  
  182.        SUBROUTINE ptkf_inqtslmarker(markerind, markertype, 
  183. & markersize, markercolour)
  184. C /*
  185. C ** \parambegin
  186. C ** \param{INTEGER}{markerind}{marker index}{OUT}
  187. C ** \param{INTEGER}{markertype}{marker type}{OUT}
  188. C ** \param{REAL}{markersize}{marker size}{OUT}
  189. C ** \param{INTEGER}{markercolour}{marker colour}{OUT}
  190. C ** \paramend
  191. C ** \blurb{This function may be used to obtain the current TSL marker 
  192. C ** attributes.}
  193. C */
  194.        INTEGER markerind, markertype
  195.        REAL markersize
  196.        INTEGER markercolour
  197.        external ptk_inqtslmarker !$PRAGMA C(ptk_inqtslmarker)
  198.  
  199.        call ptk_inqtslmarker(markerind, markertype, markersize, 
  200. & markercolour)
  201.  
  202.        RETURN
  203.        END
  204.  
  205.        SUBROUTINE ptkf_inqtslinterior(intind, intstyle, intstyleind, 
  206. & intcolour)
  207. C /*
  208. C ** \parambegin
  209. C ** \param{INTEGER}{intind}{interior index}{OUT}
  210. C ** \param{INTEGER}{intstyle}{interior style}{OUT}
  211. C ** \param{REAL}{intstyleind}{interior style index}{OUT}
  212. C ** \param{INTEGER}{intcolour}{interior colour}{OUT}
  213. C ** \paramend
  214. C ** \blurb{This function may be used to obtain the current TSL interior 
  215. C ** attributes.}
  216. C */
  217.        INTEGER intind, intstyle, intstyleind, intcolour
  218.        external ptk_inqtslinterior !$PRAGMA C(ptk_inqtslinterior)
  219.  
  220.        call ptk_inqtslinterior(intind, intstyle, intstyleind, intcolour)
  221.  
  222.        RETURN
  223.        END
  224.  
  225.        SUBROUTINE ptkf_inqtsltext(textind, textfont, textprec, 
  226. & textpath, textalign, textcolour)
  227. C /*
  228. C ** \parambegin
  229. C ** \param{INTEGER}{textind}{text index}{OUT}
  230. C ** \param{INTEGER}{textfont}{text font}{OUT}
  231. C ** \param{INTEGER}{textprec}{text precision}{OUT}
  232. C ** \param{INTEGER}{textpath}{text path}{OUT}
  233. C ** \param{INTEGER}{textalign}{text alignment}{OUT}
  234. C ** \param{INTEGER}{textcolour}{text colour}{OUT}
  235. C ** \paramend
  236. C ** \blurb{This function may be used to obtain the current TSL text 
  237. C ** attributes.}
  238. C */
  239.        INTEGER textind, textfont, textprec, textpath
  240.        INTEGER textalign, textcolour
  241.        external ptk_inqtsltext !$PRAGMA C(ptk_inqtsltext)
  242.  
  243.        call ptk_inqtsltext(textind, textfont, textprec, textpath, 
  244. & textalign, textcolour)
  245.  
  246.        RETURN
  247.        END
  248.  
  249.        SUBROUTINE ptkf_inqtslannotext(style, charheight, charup,
  250. & textalign, textpath)
  251. C /*
  252. C ** \parambegin
  253. C ** \param{INTEGER}{style}{annotation style}{OUT}
  254. C ** \param{REAL}{charheight}{annotation character height}{OUT}
  255. C ** \param{REAL}{charup(2)}{annotation character up vector}{OUT}
  256. C ** \param{INTEGER}{textalign}{annotation text alignment}{OUT}
  257. C ** \param{INTEGER}{textpath}{annotation text path}{OUT}
  258. C ** \paramend
  259. C ** \blurb{This function may be used to obtain the current TSL
  260. C ** annotation text attributes.}
  261. C */
  262.        INTEGER style
  263.        REAL charheight, charup(2)
  264.        INTEGER textalign, textpath
  265.        external ptk_inqtslannotext !$PRAGMA C(ptk_inqtslannotext)
  266.  
  267.     call ptk_inqtslannotext(style, charheight, charup, textalign, 
  268. & textpath)
  269.  
  270.        RETURN
  271.        END
  272.  
  273.        SUBROUTINE ptkf_inqtslchar(exp, spacing, height, charup)
  274. C /*
  275. C ** \parambegin
  276. C ** \param{REAL}{exp}{character expansion factor}{OUT}
  277. C ** \param{REAL}{spacing}{character spacing}{OUT}
  278. C ** \param{REAL}{height}{character height}{OUT}
  279. C ** \param{REAL}{charup(2)}{character up vector}{OUT}
  280. C ** \paramend
  281. C ** \blurb{This function may be used to obtain the current TSL character 
  282. C ** attributes.}
  283. C */
  284.        REAL exp, spacing, height, charup(2)
  285.        external ptk_inqtslchar !$PRAGMA C(ptk_inqtslchar)
  286.  
  287.        call ptk_inqtslchar(exp, spacing, height, charup)
  288.  
  289.        RETURN
  290.        END
  291.  
  292.        SUBROUTINE ptkf_inqtslctm(globaltran, localtran)
  293. C /*
  294. C ** \parambegin
  295. C ** \param{REAL}{globaltran(4, 4)}{global transformation matrix}{OUT}
  296. C ** \param{REAL}{localtran(4, 4)}{local transformation matrix}{OUT}
  297. C ** \paramend
  298. C ** \blurb{This function may be used to obtain the current TSL 
  299. C ** transformation matrices.}
  300. C */
  301.        REAL globaltran(4, 4), localtran(4, 4)
  302.        external ptk_inqtslctm !$PRAGMA C(ptk_inqtslctm)
  303.  
  304.        call ptk_inqtslctm(globaltran, localtran)
  305.  
  306.        RETURN
  307.        END
  308.  
  309.        SUBROUTINE ptkf_inqtslnameset(num, nameset, totalnum)
  310. C /*
  311. C ** \parambegin
  312. C ** \param{INTEGER}{size}{length of nameset integer list}{IN}
  313. C ** \param{INTEGER}{nameset(*)}{current nameset}{OUT}
  314. C ** \param{INTEGER}{totalsize}{actual length of nameset integer list}{OUT}
  315. C ** \paramend
  316. C ** \blurb{This function may be used to obtain the current TSL nameset.}
  317. C */
  318.        INTEGER num, nameset(num), totalnum
  319.        external ptkc_inqtslnameset !$PRAGMA C(ptkc_inqtslnameset)
  320.  
  321.        call ptkc_inqtslnameset(%val(num), nameset, totalnum)
  322.  
  323.        RETURN
  324.        END
  325.  
  326.        SUBROUTINE ptkf_inqtslids(pickid, hlhsrid, viewind)
  327. C /*
  328. C ** \parambegin
  329. C ** \param{INTEGER}{pickid}{pick identifier}{OUT}
  330. C ** \param{INTEGER}{hlhsrid}{HLHSR identifier}{OUT}
  331. C ** \param{INTEGER}{viewind}{view index}{OUT}
  332. C ** \paramend
  333. C ** \blurb{This function may be used to obtain the current TSL values
  334. C ** for pick identifier, HLHSR identifier and view index.}
  335. C */
  336.        INTEGER pickid, hlhsrid, viewind
  337.        external ptk_inqtslids !$PRAGMA C(ptk_inqtslids)
  338.  
  339.        call ptk_inqtslids(pickid, hlhsrid, viewind)
  340.  
  341.        RETURN
  342.        END
  343.  
  344.        SUBROUTINE ptkf_inqtslpattern(size, refpt, refvec)
  345. C /*
  346. C ** \parambegin
  347. C ** \param{REAL}{size(2)}{pattern size}{OUT}
  348. C ** \param{REAL}{refpt(3)}{pattern reference point}{OUT}
  349. C ** \param{REAL}{refvec(3, 2)}{pattern reference vectors}{OUT}
  350. C ** \paramend
  351. C ** \blurb{This function may be used to obtain the current TSL pattern 
  352. C ** attributes.}
  353. C */
  354.        REAL size(2), refpt(3), refvec(3, 2)
  355.        external ptk_inqtslpattern !$PRAGMA C(ptk_inqtslpattern)
  356.  
  357.        call ptk_inqtslpattern(size, refpt, refvec)
  358.  
  359.        RETURN
  360.        END
  361.  
  362.        SUBROUTINE ptkf_inqtslattrasf(attr, asf)
  363. C /*
  364. C ** \parambegin
  365. C ** \param{INTEGER}{attr}{attribute type}{IN}
  366. C ** \param{INTEGER}{asf}{attribute aspect source flag}{OUT}
  367. C ** \paramend
  368. C ** \blurb{This function may be used to obtain the current TSL 
  369. C ** aspect source flag value for attribute type {\tt attr}.}
  370. C */
  371.        INTEGER attr, asf
  372.        external ptk_inqtslattrasf !$PRAGMA C(ptk_inqtslattrasf)
  373.  
  374.        call ptk_inqtslattrasf(%val(attr), asf)
  375.  
  376.        RETURN
  377.        END
  378.  
  379. C end of tsl.f
  380.